home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / mdishe / database.bas < prev    next >
BASIC Source File  |  1994-12-29  |  9KB  |  276 lines
  1. ' ********************************************************
  2. '        MDI Standard Application Shell
  3. ' ********************************************************
  4. '
  5. ' SUMMARY
  6. ' -------
  7. ' This file is part of an MDI application "skeleton"
  8. ' created by John Blessing of Leigh Business Enterprises Ltd.
  9. '
  10. ' FEATURES
  11. ' --------
  12. ' Selection of application database.
  13. ' Compact/Repair of database.
  14. ' 'Helptips' on toolbar items.
  15. ' Support for Help files.
  16. ' MDI child forms tiling etc.
  17. ' Error trapping.
  18. ' 'Nag' screen support for shareware authors.
  19. ' Support for 3D dialogs (switched off in design mode
  20. '   to prevent GPFs)
  21. '
  22. ' USE
  23. ' ---
  24. ' You need VB Pro to use this shell, although it could be
  25. ' modified to run under the standard edition.
  26. '
  27. ' You will need to set up some information in APP.BAS,
  28. ' particularly in SetAppInfo().  You will also need to add
  29. ' your own application specific code to this module.
  30. '
  31. ' DISTRIBUTION
  32. ' ------------
  33. ' This program is "FreeWare" and may be used and distributed
  34. ' as you wish.
  35. '
  36. ' It incorporates some ideas/code from other authors and these
  37. ' are acknowledged in the appropriate module.
  38. '
  39. ' We hope that you will find it useful.  If you wish to discuss it
  40. ' then please e-mail us on Compuserve 100444,623.
  41. '
  42. ' ADVERTISEMENT!
  43. ' --------------
  44. ' Are you looking for a helpdesk system? Or does your company
  45. ' want to track and monitor the progress of any work activity?
  46. ' We market a system which could be of interest to you.
  47. '
  48. ' PROGRESS is available for download from the Business section
  49. ' of the Windows Shareware forum on Compuserve
  50. ' (filename PRGRSS10.ZIP).  It's a large program, so in the
  51. ' same section you will also find the help files and
  52. ' documentation as  PRGSSDOC.ZIP which is quicker to download
  53. ' and will give you a good idea of the functionality of PROGRESS.
  54. '
  55. ' Dec 1994
  56. Option Explicit
  57.  
  58. '======================================================================
  59. 'Form/Module:
  60. '   Database.bas
  61. '
  62. 'Procedure:
  63. '   CompactDbase
  64. '
  65. 'Parameters:
  66. '   cmdialog    The common dialog to be used for selection of the file
  67. '
  68. 'Returns:
  69. '   None
  70. '
  71. 'Modifications:
  72. '   26/12/94   JBL     Build
  73. '
  74. 'Description:
  75. '   Compacts an Access database
  76. '======================================================================
  77. '
  78. Sub CompactDbase (cmdialog As CommonDialog)
  79.  
  80.     Dim sDbase, sBakDb         As String
  81.     Dim db                  As Database
  82.  
  83.     On Error Resume Next
  84.        
  85.     sDbase = sSelectDbase(cmdialog, "Compact")
  86.     If sDbase <> "" Then
  87.  
  88.         screen.MousePointer = HOURGLASS
  89.         
  90.         'try and open it in exclusive mode
  91.         Set db = OpenDatabase(sDbase, True)
  92.         If Err = 0 Then
  93.             'opened ok so close it
  94.             db.Close
  95.             
  96.             'construct the correct .bak filename
  97.             sBakDb = Left$(sDbase, InStr(sDbase, ".")) & "BAK"
  98.  
  99.             'give a chance to exit
  100.             If MsgBox("Your existing " & sDbase & sGNl & "will be copied to " & sBakDb, MB_OKCANCEL + MB_ICONEXCLAMATION, "Compact database") = IDCANCEL Then
  101.                 screen.MousePointer = DEFAULT
  102.                 Exit Sub
  103.             End If
  104.  
  105.             'kill any existing .bak
  106.             Kill sBakDb
  107.             If Err <> 0 Then Err = 0'err because no existing .bak
  108.  
  109.             'copy original to sBakdb
  110.             FileCopy sDbase, sBakDb
  111.             If Err <> 0 Then
  112.                 'call the generic error handler
  113.                 GenErrorHandler "Database.bas - CompactDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
  114.                 screen.MousePointer = DEFAULT
  115.                 Exit Sub
  116.             End If
  117.     
  118.             'kill the existing database because can't compact into an existing one
  119.             Kill sDbase
  120.             DoEvents
  121.             If Err = 0 Then
  122.                 'deleted ok so compact it
  123.                 CompactDatabase sBakDb, sDbase
  124.                 If Err <> 0 Then
  125.                     'call the generic error handler
  126.                     GenErrorHandler "Database.bas - CompactDbase()", Err, Error$
  127.                     'copy bakdb to original
  128.                     FileCopy sBakDb, sDbase
  129.                     If Err <> 0 Then
  130.                         'call the generic error handler
  131.                         GenErrorHandler "Database.bas - CompactDbase()", Err, Error$
  132.                         screen.MousePointer = DEFAULT
  133.                         Exit Sub
  134.                     End If
  135.                 End If
  136.             End If
  137.             MsgBox "Compact completed."
  138.         Else
  139.             'call the generic error handler
  140.             GenErrorHandler "Database.BAS - CompactDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
  141.         End If
  142.     End If
  143.     
  144.     
  145.     screen.MousePointer = DEFAULT
  146.  
  147. End Sub
  148.  
  149. '======================================================================
  150. 'Form/Module:
  151. '   Database.bas
  152. '
  153. 'Procedure:
  154. '   RepairDbase
  155. '
  156. 'Parameters:
  157. '   cmdialog    The common dialog to be used for selection of the file
  158. '
  159. 'Returns:
  160. '   None
  161. '
  162. 'Modifications:
  163. '   26/12/94   JBL     Build
  164. '
  165. 'Description:
  166. '   Repairs an Access database
  167. '======================================================================
  168. '
  169. Sub RepairDbase (cmdialog As CommonDialog)
  170.     Dim sDbase  As String
  171.     Dim db      As Database
  172.  
  173.     On Error Resume Next
  174.        
  175.     sDbase = sSelectDbase(cmdialog, "Repair")
  176.     If sDbase <> "" Then
  177.  
  178.         screen.MousePointer = HOURGLASS
  179.         
  180.         'try and open it in exclusive mode
  181.         Set db = OpenDatabase(sDbase, True)
  182.         If Err = 0 Then
  183.             'opened ok so close it
  184.             db.Close
  185.             DoEvents
  186.             'repair it
  187.             RepairDatabase sDbase
  188.             If Err = 0 Then
  189.                 MsgBox "Repair completed successfully."
  190.             Else
  191.                 'call the generic error handler
  192.                 GenErrorHandler "Database.bas - RepairDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
  193.             End If
  194.         Else
  195.             'call the generic error handler
  196.             GenErrorHandler "Database.BAS - RepairDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
  197.         End If
  198.     End If
  199.  
  200.     screen.MousePointer = DEFAULT
  201.  
  202.  
  203. End Sub
  204.  
  205. '======================================================================
  206. 'Form/Module:
  207. '   Database.bas
  208. '
  209. 'Procedure:
  210. '   sSelectDbase
  211. '
  212. 'Parameters
  213. '   cmdialog       the control used to select the filename
  214. '   sMode           either NEW, OPEN, REPAIR or COMPACT
  215. '
  216. 'Returns
  217. '   The name of the selected file or empty string
  218. '
  219. 'Modifications:
  220. '   26/12/94   JBL     Build
  221. '
  222. 'Description:
  223. '   Creates a new Access database then opens it
  224. '======================================================================
  225. Function sSelectDbase (cmdialog As CommonDialog, sMode As String) As String
  226.     Dim db  As Database
  227.  
  228.     On Error Resume Next
  229.  
  230.  
  231.     sMode = UCase$(sMode)
  232.  
  233.     'set up the common dialog control
  234.     cmdialog.DefaultExt = "mdb"
  235.     cmdialog.Filename = ""
  236.     cmdialog.CancelError = True
  237.     cmdialog.Filter = "Database (*.mdb)|*.mdb|All files (*.*)|*.*|"
  238.     cmdialog.Flags = &H4& Or &H1000& 'remove readonly checkbox
  239.     
  240.     Select Case sMode
  241.     Case "NEW"
  242.         cmdialog.DialogTitle = "New Database"
  243.         cmdialog.Action = 2
  244.     Case "OPEN"
  245.         cmdialog.DialogTitle = "Open Database"
  246.         cmdialog.Action = 1
  247.     Case "REPAIR"
  248.         cmdialog.DialogTitle = "Repair Database"
  249.         cmdialog.Action = 1
  250.     Case "COMPACT"
  251.         cmdialog.DialogTitle = "Compact Database"
  252.         cmdialog.Action = 1
  253.     End Select
  254.  
  255.     If Err <> 32755 Then    'i.e not cancel
  256.         sSelectDbase = cmdialog.Filename
  257.         If sMode <> "NEW" Then
  258.             'don't try and open if one doesn't exist
  259.             Set db = OpenDatabase(cmdialog.Filename, True)
  260.             If Err = 0 Then
  261.                 'opened OK so return the filename
  262.                 sSelectDbase = cmdia